home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
-
- ;=====================================
- (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
- (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
- (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
- "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
- ;;; Does simple constant folding. This works for everything that doesn't have
- ;;; side-effects.
- ;;; ALL operands must be constant.
- ;;; Note that commutative-constant-folder can hack this case perfectly well
- ;;; by himself for the functions he handles.
- (defun constant-fold-optimizer (form)
- (let ((eval-when-load-p nil))
- (flet ((constant-form-p (x)
- (when (constant-form-p x)
- (cond ((and (listp x)
- (eq (car x) 'quote)
- (listp (cadr x))
- (eq (caadr x) eval-at-load-time-marker))
- (setq eval-when-load-p t)
- (cdadr x))
- (t x)))))
- (if (every (cdr form) #'constant-form-p)
- (if eval-when-load-p
- (list 'quote
- (list* eval-at-load-time-marker
- (car form)
- (mapcar #'constant-form-p (cdr form))))
- (condition-case (error-object)
- (multiple-value-call #'(lambda (&rest values)
- (if (= (length values) 1)
- `',(first values)
- `(values ,@(mapcar #'(lambda (x) `',x)
- values))))
- (eval form))
- (error
- (phase-1-warning "Constant form left unoptimized: ~S~%because: ~⑨~A~⑧"
- form error-object)
- form)))
- form))))
-
-
- ;=====================================
- (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
- (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
- (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
- "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
- ;;;
- ;;; The damn compiler doesn't compile random forms that appear at top level.
- ;;; Its difficult to do because you have to get an associated function spec
- ;;; to go with those forms. This handles that by defining a special form,
- ;;; top-level-form that compiles its body. It takes a list of eval-when
- ;;; times just like eval when does. It also takes a name which it uses
- ;;; to construct a function spec for the top-level-form function it has
- ;;; to create.
- ;;;
- ;
- ;si::
- ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
- ;
- ;si::
- ;(define-function-spec-handler pcl::top-level-form
- ; (operation fspec &optional arg1 arg2)
- ; (let ((name (cadr fspec)))
- ; (selectq operation
- ; (validate-function-spec (and (= (length fspec) 2)
- ; (or (symbolp name)
- ; (listp name))))
- ; (fdefine
- ; (setf (gethash name *top-level-form-fdefinitions*) arg1))
- ; ((fdefinition fdefinedp)
- ; (gethash name *top-level-form-fdefinitions*))
- ; (fdefinition-location
- ; (ferror "It is not possible to get the fdefinition-location of ~s."
- ; fspec))
- ; (fundefine (remhash name *top-level-form-fdefinitions*))
- ; (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
- ;
- ;;;
- ;;; This is basically stolen from PROGN (surprised?)
- ;;;
- ;(si:define-special-form pcl::top-level-form (name times
- ; &body body
- ; &environment env)
- ; (declare lt:(arg-template . body) (ignore name))
- ; (si:check-eval-when-times times)
- ; (when (member 'eval times) (si:eval-body body env)))
- ;
- ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
- ; (lt::mapforms-list original-form form (cddr form) 'eval usage))
-
- ;;; This is the normal function for looking at each form read from the file and calling
- ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
- ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is
- ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
- ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
- ; (CATCH-ERROR-RESTART
- ; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
- ; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
- ; (LET ((ERROR-MESSAGE-HOOK
- ; #'(LAMBDA ()
- ; (DECLARE (SYS:DOWNWARD-FUNCTION))
- ; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
- ; DBG:*ERROR-MESSAGE-PRINLEVEL*
- ; DBG:*ERROR-MESSAGE-PRINLENGTH*
- ; FORM))))
- ; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
- ; (WHEN (LISTP FORM) ;Ignore atoms at top-level
- ; (LET ((FUNCTION (FIRST FORM)))
- ; (SELECTQ FUNCTION
- ; ((QUOTE)) ;and quoted constants e.g. 'COMPILE
- ; ((PROGN)
- ; (DOLIST (FORM (CDR FORM))
- ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
- ; ((EVAL-WHEN)
- ; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
- ; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
- ; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
- ; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
- ; (FORMS (CDDR FORM)))
- ; (COND (LOAD-P
- ; (DOLIST (FORM FORMS)
- ; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
- ; (COMPILE-P
- ; (DOLIST (FORM FORMS)
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
- ; ((DEFUN)
- ; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
- ; (IF (EQ (CDR TEM) (CDR FORM))
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
- ; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
- ; ((MACRO)
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
- ; ((DECLARE)
- ; (DOLIST (FORM (CDR FORM))
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
- ; ;; (DECLARE (SPECIAL ... has load-time action as well.
- ; ;; All other DECLARE's do not.
- ; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
- ; ((COMPILER-LET)
- ; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
- ; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
- ; ((SI:DEFINE-SPECIAL-FORM)
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
- ; ((MULTIPLE-DEFINITION)
- ; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
- ; (LET ((NAME-VALID (AND (NOT (NULL NAME))
- ; (OR (SYMBOLP NAME)
- ; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
- ; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
- ; (UNLESS (AND NAME-VALID TYPE-VALID)
- ; (WARN "(~S ~S ~S ...) is invalid because~@
- ; ~:[~S is not valid as a definition name~;~*~]~
- ; ~:[~&~S is not valid as a definition type~;~*~]"
- ; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
- ; (LET* ((COMPILED-BODY NIL)
- ; (COMPILE-FUNCTION *COMPILE-FUNCTION*)
- ; (*COMPILE-FUNCTION*
- ; (LAMBDA (OPERATION &REST ARGS)
- ; (DECLARE (SYS:DOWNWARD-FUNCTION))
- ; (SELECTQ OPERATION
- ; (:DUMP-FORM
- ; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
- ; (FIRST ARGS))
- ; COMPILED-BODY))
- ; (:INSTALL-DEFINITION
- ; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
- ; COMPILED-BODY))
- ; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
- ; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
- ; ,@LOCAL-DECLARATIONS)))
- ; (DOLIST (FORM BODY)
- ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
- ; (FUNCALL COMPILE-FUNCTION :DUMP-FORM
- ; `(LOAD-MULTIPLE-DEFINITION
- ; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
- ; ((pcl::top-level-form)
- ; (destructuring-bind (name times . body)
- ; (cdr form)
- ; (si:check-eval-when-times times)
- ; (let ((compile-p (or (memq 'compile times)
- ; (and compile-time-too (memq 'eval times))))
- ; (load-p (or (memq 'load times)
- ; (memq 'cl:load times)))
- ; (fspec `(pcl::top-level-form ,name)))
- ; (cond (load-p
- ; (compile-from-stream-1
- ; `(progn (defun ,fspec () . ,body)
- ; (funcall (function ,fspec)))
- ; (and compile-p ':force)))
- ; (compile-p
- ; (dolist (b body)
- ; (funcall *compile-form-function* form ':force nil)))))))
- ; (OTHERWISE
- ; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
- ; (IF TEM
- ; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
- ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
- ;
- ;
-
-
- dw::
- (defun symbol-flavor-or-cl-type (symbol)
- (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
- non-atomic-deftype))
- (multiple-value-bind (result foundp)
- (gethash symbol *flavor-or-cl-type-cache*)
- (let ((frob
- (if foundp result
- (setf (gethash symbol *flavor-or-cl-type-cache*)
- (or (get symbol 'flavor:flavor)
- (let ((class (get symbol 'clos-internals::class-for-name)))
- (when (and class
- (not (typep class 'clos:built-in-class)))
- class))
- (not (null (defstruct-type-p symbol)))
- (let* ((deftype (get symbol 'deftype))
- (descriptor (symbol-presentation-type-descriptor symbol))
- (typep
- (unless (and descriptor
- (presentation-type-explicit-type-function
- descriptor))
- ;; Don't override the one defined in the presentation-type.
- (get symbol 'typep)))
- (atomic-subtype-parent (find-atomic-subtype-parent symbol))
- (non-atomic-deftype
- (when (and (not descriptor) deftype)
- (not (member (first (type-arglist symbol))
- '(&rest &key &optional))))))
- (if (or typep (not (atom deftype))
- non-atomic-deftype
- ;; deftype overrides atomic-subtype-parent.
- (and (not deftype) atomic-subtype-parent))
- (list-in-area *handler-dynamic-area*
- deftype typep atomic-subtype-parent
- non-atomic-deftype)
- deftype)))))))
- (locally (declare (inline compiled-function-p))
- (etypecase frob
- (array (values frob))
- (instance (values frob))
- (null (values nil))
- ((member t) (values nil t))
- (compiled-function (values nil nil frob))
- (lexical-closure (values nil nil frob))
- (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
- frob
- (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
- (symbol (values nil nil nil nil frob)))))))
-
-
-